home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src / tclXlist.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-26  |  8.4 KB  |  330 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCLExtend
  3. #endif
  4. /* 
  5.  * tclXlist.c --
  6.  *
  7.  *  Extended Tcl list commands.
  8.  *-----------------------------------------------------------------------------
  9.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  10.  *
  11.  * Permission to use, copy, modify, and distribute this software and its
  12.  * documentation for any purpose and without fee is hereby granted, provided
  13.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14.  * Mark Diekhans make no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without express or
  16.  * implied warranty.
  17.  *-----------------------------------------------------------------------------
  18.  * $Id: tclXlist.c,v 2.5 1993/08/05 06:41:55 markd Exp $
  19.  *-----------------------------------------------------------------------------
  20.  */
  21.  
  22. #include "tclExtdInt.h"
  23.  
  24.  
  25. /*
  26.  *-----------------------------------------------------------------------------
  27.  *
  28.  * Tcl_LvarcatCmd --
  29.  *     Implements the TCL lvarpop command:
  30.  *         lvarcat var string ?string...?
  31.  *
  32.  * Results:
  33.  *      Standard TCL results.
  34.  *
  35.  *-----------------------------------------------------------------------------
  36.  */
  37. int
  38. Tcl_LvarcatCmd (clientData, interp, argc, argv)
  39.     ClientData  clientData;
  40.     Tcl_Interp *interp;
  41.     int         argc;
  42.     char      **argv;
  43. {
  44.     int        listArgc, idx, listIdx;
  45.     char     **listArgv;
  46.     char      *staticArgv [12];
  47.     char      *varContents, *newStr, *result;
  48.  
  49.     if (argc < 3) {
  50.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  51.                           " var string ?string...?", (char *) NULL);
  52.         return TCL_ERROR;
  53.     }
  54.  
  55.     varContents = Tcl_GetVar (interp, argv[1], 0);
  56.  
  57.     if (varContents != NULL)
  58.         listArgc = argc - 1;
  59.     else
  60.         listArgc = argc - 2;
  61.  
  62.     if (listArgc < (sizeof (staticArgv) / sizeof (char *))) {
  63.         listArgv = staticArgv;
  64.     } else {
  65.         listArgv = (char **) ckalloc (listArgc * sizeof (char *));
  66.     }
  67.     
  68.     if (varContents != NULL) {
  69.         listArgv [0] = varContents;
  70.         listIdx = 1;
  71.     } else {
  72.         listIdx = 0;
  73.     }
  74.     for (idx = 2; idx < argc; idx++, listIdx++)
  75.         listArgv [listIdx] = argv [idx];
  76.  
  77.     newStr = Tcl_Concat (listArgc, listArgv);
  78.     result = Tcl_SetVar (interp, argv [1], newStr, TCL_LEAVE_ERR_MSG);
  79.  
  80.     ckfree (newStr);
  81.     if (listArgv != staticArgv)
  82.         ckfree ((char *) listArgv);
  83.  
  84.     /*
  85.      * If all is ok, return the variable contents as a "static" result.
  86.      */
  87.     if (result != NULL) {
  88.         interp->result = result;
  89.         return TCL_OK;
  90.     } else {
  91.         return TCL_ERROR;
  92.     }
  93. }
  94.  
  95. /*
  96.  *-----------------------------------------------------------------------------
  97.  *
  98.  * Tcl_LvarpopCmd --
  99.  *     Implements the TCL lvarpop command:
  100.  *         lvarpop var ?index? ?string?
  101.  *
  102.  * Results:
  103.  *      Standard TCL results.
  104.  *
  105.  *-----------------------------------------------------------------------------
  106.  */
  107. int
  108. Tcl_LvarpopCmd (clientData, interp, argc, argv)
  109.     ClientData  clientData;
  110.     Tcl_Interp *interp;
  111.     int         argc;
  112.     char      **argv;
  113. {
  114.     int        listArgc, listIdx, idx;
  115.     char     **listArgv;
  116.     char      *varContents, *resultList, *returnElement;
  117.  
  118.     if ((argc < 2) || (argc > 4)) {
  119.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  120.                           " var ?index? ?string?", (char *) NULL);
  121.         return TCL_ERROR;
  122.     }
  123.  
  124.     varContents = Tcl_GetVar (interp, argv[1], TCL_LEAVE_ERR_MSG);
  125.     if (varContents == NULL)
  126.         return TCL_ERROR;
  127.  
  128.     if (Tcl_SplitList (interp, varContents, &listArgc, &listArgv) == TCL_ERROR)
  129.         return TCL_ERROR;
  130.  
  131.     if (argc == 2) 
  132.         listIdx = 0;
  133.     else {
  134.         if (Tcl_GetInt (interp, argv[2], &listIdx) != TCL_OK)
  135.             goto errorExit;
  136.     }
  137.  
  138.     /*
  139.      * Just ignore out-of bounds requests, like standard Tcl.
  140.      */
  141.     if ((listIdx < 0) || (listIdx >= listArgc)) {
  142.         goto okExit;
  143.     }
  144.     returnElement = listArgv [listIdx];
  145.  
  146.     if (argc == 4)
  147.         listArgv [listIdx] = argv [3];
  148.     else {
  149.         listArgc--;
  150.         for (idx = listIdx; idx < listArgc; idx++)
  151.             listArgv [idx] = listArgv [idx+1];
  152.     }
  153.  
  154.     resultList = Tcl_Merge (listArgc, listArgv);
  155.     if (Tcl_SetVar (interp, argv [1], resultList, TCL_LEAVE_ERR_MSG) == NULL) {
  156.         ckfree (resultList);
  157.         goto errorExit;
  158.     }
  159.     ckfree (resultList);
  160.  
  161.     Tcl_SetResult (interp, returnElement, TCL_VOLATILE);
  162.   okExit:
  163.     ckfree((char *) listArgv);
  164.     return TCL_OK;
  165.  
  166.   errorExit:
  167.     ckfree((char *) listArgv);
  168.     return TCL_ERROR;;
  169. }
  170.  
  171. /*
  172.  *-----------------------------------------------------------------------------
  173.  *
  174.  * Tcl_LvarpushCmd --
  175.  *     Implements the TCL lvarpush command:
  176.  *         lvarpush var string ?index?
  177.  *
  178.  * Results:
  179.  *      Standard TCL results.
  180.  *
  181.  *-----------------------------------------------------------------------------
  182.  */
  183. int
  184. Tcl_LvarpushCmd (clientData, interp, argc, argv)
  185.     ClientData  clientData;
  186.     Tcl_Interp *interp;
  187.     int         argc;
  188.     char      **argv;
  189. {
  190.     int        listArgc, listIdx, idx;
  191.     char     **listArgv;
  192.     char      *varContents, *resultList;
  193.  
  194.     if ((argc < 3) || (argc > 4)) {
  195.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  196.                           " var string ?index?", (char *) NULL);
  197.         return TCL_ERROR;
  198.     }
  199.  
  200.     varContents = Tcl_GetVar (interp, argv[1], 0);
  201.     if (varContents == NULL)
  202.         varContents = "";
  203.  
  204.     if (Tcl_SplitList (interp, varContents, &listArgc, &listArgv) == TCL_ERROR)
  205.         return TCL_ERROR;
  206.  
  207.     if (argc == 3) 
  208.         listIdx = 0;
  209.     else {
  210.         if (Tcl_GetInt (interp, argv[3], &listIdx) != TCL_OK)
  211.             goto errorExit;
  212.     }
  213.  
  214.     /*
  215.      * Out-of-bounds request go to the start or end, as with most of Tcl.
  216.      */
  217.     if (listIdx < 0)
  218.         listIdx = 0;
  219.     else
  220.         if (listIdx > listArgc)
  221.             listIdx = listArgc;
  222.  
  223.     /*
  224.      * This code takes advantage of the fact that a NULL entry is always
  225.      * returned by Tcl_SplitList, but not required by Tcl_Merge.
  226.      */
  227.     for (idx = listArgc; idx > listIdx; idx--)
  228.         listArgv [idx] = listArgv [idx - 1];
  229.  
  230.     listArgv [listIdx] = argv [2];
  231.  
  232.     resultList = Tcl_Merge (listArgc + 1, listArgv);
  233.  
  234.     if (Tcl_SetVar (interp, argv [1], resultList, TCL_LEAVE_ERR_MSG) == NULL) {
  235.         ckfree (resultList);
  236.         goto errorExit;
  237.     }
  238.  
  239.     ckfree (resultList);
  240.     ckfree((char *) listArgv);
  241.     return TCL_OK;
  242.  
  243.   errorExit:
  244.     ckfree((char *) listArgv);
  245.     return TCL_ERROR;;
  246. }
  247.  
  248. /*
  249.  *-----------------------------------------------------------------------------
  250.  *
  251.  * Tcl_LemptyCmd --
  252.  *     Implements the strcat TCL command:
  253.  *         lempty list
  254.  *
  255.  * Results:
  256.  *     Standard TCL result.
  257.  *
  258.  *-----------------------------------------------------------------------------
  259.  */
  260. int
  261. Tcl_LemptyCmd (clientData, interp, argc, argv)
  262.     ClientData   clientData;
  263.     Tcl_Interp  *interp;
  264.     int          argc;
  265.     char       **argv;
  266. {
  267.     char *scanPtr;
  268.  
  269.     if (argc != 2) {
  270.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " list",
  271.                           (char *) NULL);
  272.         return TCL_ERROR;
  273.     }
  274.  
  275.     scanPtr = argv [1];
  276.     while ((*scanPtr != '\0') && (ISSPACE (*scanPtr)))
  277.         scanPtr++;
  278.     sprintf (interp->result, "%d", (*scanPtr == '\0'));
  279.     return TCL_OK;
  280.  
  281. }
  282.  
  283. /*
  284.  *-----------------------------------------------------------------------------
  285.  *
  286.  * Tcl_LassignCmd --
  287.  *     Implements the TCL assign_fields command:
  288.  *         lassign list varname ?varname...?
  289.  *
  290.  * Results:
  291.  *      Standard TCL results.
  292.  *
  293.  *-----------------------------------------------------------------------------
  294.  */
  295. int
  296. Tcl_LassignCmd (clientData, interp, argc, argv)
  297.     ClientData  clientData;
  298.     Tcl_Interp *interp;
  299.     int         argc;
  300.     char      **argv;
  301. {
  302.     int        listArgc, listIdx, idx;
  303.     char     **listArgv;
  304.     char      *varValue;
  305.  
  306.     if (argc < 3) {
  307.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  308.                           " list varname ?varname..?", (char *) NULL);
  309.         return TCL_ERROR;
  310.     }
  311.  
  312.     if (Tcl_SplitList (interp, argv[1], &listArgc, &listArgv) == TCL_ERROR)
  313.         return TCL_ERROR;
  314.  
  315.     for (idx = 2, listIdx = 0; idx < argc; idx++, listIdx++) {
  316.  
  317.         varValue = (listIdx < listArgc) ? listArgv[listIdx] : "" ;
  318.         if (Tcl_SetVar (interp, argv[idx], varValue,
  319.            TCL_LEAVE_ERR_MSG) == NULL) {
  320.             goto error_exit;
  321.         }
  322.     }
  323.     ckfree((char *) listArgv);
  324.     return TCL_OK;
  325.  
  326.   error_exit:
  327.     ckfree((char *) listArgv);
  328.     return TCL_ERROR;
  329. }
  330.